
;;定义y表达式与lisp函数等价,使用y表达式的参数
(defmacro func-equal-def(y-exp lisp-func)
   (let ((y-func (if (atom y-exp) y-exp (car y-exp))) (par (if (atom y-exp) nil (cdr y-exp))))
     `(defun ,y-func ,par (apply ,lisp-func (list ,@par)))))



;;使用缓存解决递归函数重复计算问题

(defun get-cache-name(fn)
  (read-from-string (format nil "~a-cache" fn)))


(defun func-to-cache(l fn &optional nfn)
  (if (null nfn) (setf nfn fn))
  (if (and (consp l) (atom (car l))(eql (car l) fn))
      (let ((ll (list 'cache-para (read-from-string (format nil "#'~a" nfn)))))
	(loop for i from 1 to (1- (length l)) do
	     (setf ll (append ll (list (nth i l)))))
	ll)
      (if (atom l)
	  l
	  (cons (func-to-cache (car l) fn nfn)(func-to-cache (cdr l) fn nfn)))))

(defmacro cache-func-def(fn par &body body)
  (let ((f (get-cache-name fn)))
  `(setf (fdefinition ',fn)
	 #'(lambda ,par
	     (let ((cache-para (make-hash-table :test #'equal)))
	       (labels ((cache-para(fn para &optional value)
			  (multiple-value-bind (val win) (gethash para cache-para)
			    (if win
				val
				(if value
				    (setf (gethash para cache-para) value)
				    (cond ((null para) (setf (gethash para cache-para) (apply fn nil)))
					  ((atom para) (setf (gethash para cache-para) (apply fn (list para))))
					  ((consp para) (setf (gethash para cache-para) (apply fn para)))
					  (t (format t "error.")))))))
			(,f ,par ,@(func-to-cache body fn f)))
		 (,f ,@par)))))))

(defun symbol-not-key(s)
  (and (not (keywordp s))(symbolp s)))
(defun read-list(str)
   (let ((current-list nil))
	(with-open-file (fp str) 
	  (when fp
	    (do ((l (read fp nil) ))
		((null l) (reverse current-list))
	      (push l current-list)
	      (setf l (read fp nil)))))))

;;缺省函数定义:(define (:default func par) '(in out file)) ---(list ,@par)=in
(defmacro default-func-def(name-list &optional in out file)
  (let ((func-name (car name-list))(par (cdr name-list)))
    `(defun ,func-name ,par
       (let ((v-list ',(if file (read-list file))))
	 (if (and (null ,in)(null ,out)(null ,file))
	     t
	     (if (equal (list ,@par) ,in)
		 ,out
		 (if (consp v-list)
		     (progn (dolist (i v-list) (if (and (consp i)(equal (list ,@par) (car i)))(return-from ,func-name (cadr i))))
			    nil)
		     nil)))))))

(defmacro define(name-list &body body)
  (if (null body) (setf body nil))
  (cond ((atom name-list)`(defparameter ,name-list ,@body))
	;((and (consp name-list)(symbol-not-key (car name-list))(null (cdr name-list)))`(defun ,(car name-list) () ,@body))
	((and (consp name-list)(symbol-not-key (car name-list)))`(defun ,(car name-list) ,(cdr name-list) ,@body))
	((and (consp name-list)(keywordp (car name-list))(or (eql (car name-list) ':macro)(eql (car name-list) ':宏)))
	 `(defmacro ,(cadr name-list) ,(cddr name-list) ,@body))
	((and (consp name-list)(keywordp (car name-list))(or (eql (car name-list) ':cache)(eql (car name-list) ':缓存)))
	 `(cache-func-def ,(cadr name-list) ,(cddr name-list) ,@body))
	((and (consp name-list)(keywordp (car name-list))(or (eql (car name-list) ':default)(eql (car name-list) ':缺省)))
	 `(default-func-def ,(cdr name-list) ,(nth 0 body) ,(nth 1 body) ,(nth 2 body)))
	((and (consp name-list)(keywordp (car name-list))(or (eql (car name-list) ':useby)(eql (car name-list) ':引用)))
	 `(func-equal-def ,(cadr name-list) ,@body))
;;结构,类,客户定义等关键字类型尚未实现。
	((and (consp name-list)(consp (car name-list))) `(let ,name-list ,@body))))
(defmacro 定义(name-list &body body)
  (if (atom name-list)
  `(define ,name-list ,@body)
  (if (keywordp (car name-list))
    `(define (,(car name-list) ,@(cadr name-list)) ,@body)
    `(define ,name-list ,@body))))


(defmacro 如果(cond then &optional else)
  (if else
      `(if ,cond ,then ,else)
      `(if ,cond ,then)))
      
(defmacro 分类( &rest args)
  ( if (null args)
       nil
       ( let ((clause (car args)))
	 ( if (cdr clause)
	      `( if ,(car clause)
		    ( progn ,@(cdr clause))
		    (分类 ,@(cdr args)))
	      `(or ,(car clause)
		   (分类 ,@(cdr args)))))))

(defmacro travel-list(data index &body body)
  (let ((fn (gensym)))
    `(let ((,index ,data)(,fn (lambda(,index) ,@body)))
       (tr-list ,index ,fn))))
(defun tr-list(l fn)
  (if (null l) nil
      (if (atom l) (funcall fn l)
	  (cons (tr-list (car l) fn)(tr-list (cdr l) fn)))))
;;例子
(defun >=20(l)
  ;(format t "l=[~a]~%" l)
  (and (integerp l)(>= l 20)))
(defun num>=(i l)
  (and (integerp l)(>= l i)))
(defun num>(i l)
  (and (integerp l)(> l i)))
(defun num-step(i l)
  (setf l (+ l i)))
(defun listn>=(i l)
  (cond ((and (consp i)(consp l)(= (length i)(length l)))
	 (let ((flag nil))
	   (dotimes (n (length l)) (if (and (integerp (nth n i))(integerp (nth n l))(>= (nth n l)(nth n i)))
				       (setf flag t)
				       (return-from listn>= nil)))
	   flag))
	(t nil)))
(defun listn>(i l)
  (cond ((and (consp i)(consp l)(= (length i)(length l)))
	 (let ((flag nil))
	   (dotimes (n (length l)) (if (and (integerp (nth n i))(integerp (nth n l))(> (nth n l)(nth n i)))
				       (setf flag t)
				       (return-from listn> nil)))
	   flag))
	(t nil)))
(defun listn-step(i l)
  (cond ((and (consp i)(consp l)(= (length i)(length l)))
	 (let ((k nil))
	   (dotimes (n (length l))(if (and (integerp (nth n i))(integerp (nth n l))) (push (+ (nth n i)(nth n l)) k)
				    (return-from listn-step nil)))
	   (reverse k)))
	(t nil)))
(defun list1>=(i l)
  (cond ((and (consp i)(consp l)(= (length i)(length l)))
	 (let ((flag nil))
	   (dotimes (n (length l)) (if (and (integerp (nth n i))(integerp (nth n l))(>= (nth n l)(nth n i)))
				       (return-from list1>= t)
				       (setf flag nil)))
	   flag))
	(t nil)))
(defun list1>(i l)
  (cond ((and (consp i)(consp l)(= (length i)(length l)))
	 (let ((flag nil))
	   (dotimes (n (length l)) (if (and (integerp (nth n i))(integerp (nth n l))(> (nth n l)(nth n i)))
				       (return-from list1> t)
				       (setf flag nil)))
	   flag))
	(t nil)))
  

(defmacro travel-other(fn fn-par data index &body body)
  (let ((f (gensym))(func-par (gensym)))
    `(let ((,index ,data)(,f (lambda(,index) ,@body)))
       (setf ,func-par (append ,fn-par (list ,index ,f)))
       ;(format t "par=[~a]~%" ,func-par)
       (apply ,fn ,func-par))))


(defmacro travel(data method index &body body)
  (let ((m-val (gensym))(fn (gensym))(fn-par (gensym))(fs (gensym))(fs-par (gensym))(myfn-par (gensym))(myfs-par (gensym)))
    `(if (atom ,method)
	(cond ((typep ,data 'list)
	       (cond ((or (eql ,method 'for-child)(eql ,method '子项)(eql ,method :for-child)(eql ,method :子项))
		      (dolist (,index ,data) ,@body))
		     ((or (eql ,method 'for-index)(eql ,method '索引)(eql ,method :for-index)(eql ,method :索引))
		      (dotimes (,index (length ,data)) ,@body))
		     ((or (eql ,method 'for-atom)(eql ,method '元素)(eql ,method :for-atom)(eql ,method :元素))
		      (travel-list ,data ,index ,@body))
		     (t (format t "未定义的列表方法。[~a]~%" ,method))))
	      ((typep ,data 'sequence)
	       (cond ((or (eql ,method 'for-index)(eql ,method '索引)(eql ,method :for-index)(eql ,method :索引))
		      (dotimes (,index (length ,data)) ,@body))
		     (t (format t "未定义的序列方法。[~a]~%" ,method))))
	      (t (format t "未定义的数据类型[~a]--[~a]。~%" (type-of ,data) ,data)))
	(progn
	;(format t "method=[~a]~%" ,method)
	  (setf ,m-val nil ,fn nil ,fn-par nil ,fs nil ,fs-par nil)
	  (if (atom (car ,method))(setf ,m-val (car ,method)))
	  (if (atom (cadr ,method))(setf ,fn (cadr ,method) ,fn-par nil)
	      (if (consp (cadr ,method))
		  (progn (if (atom (car (cadr ,method)))(setf ,fn (car (cadr ,method)) ,fn-par (cdr (cadr ,method))))
			 (if (atom (car (caddr ,method)))(setf ,fs (car (caddr ,method)) ,fs-par (cdr (caddr ,method)))))))
	  ;(format t "fn=[~a] fn-par=[~a] fs=[~a] fs-par=[~a] data=[~a] ~%" ,fn ,fn-par ,fs ,fs-par ,data)	
	  (cond ((or (eql ,m-val 'for-special)(eql ,m-val '自定义)(eql ,m-val :for-special)(eql ,m-val :自定义))
		 (travel-other ,fn ,fn-par ,data ,index ,@body))
;;'for-next 'for-special需要对传入的参数进行求值,尚有问题,只能使用隐含参数函数(见测试用例tr-list,>=20)
		((or (eql ,m-val 'for-next)(eql ,m-val '下一步)(eql ,m-val :for-next)(eql ,m-val :下一步))
	
		 (let ((,index ,data))(if (and ,fn ,fs)
					  (progn (setf ,myfn-par (append ,fn-par (list ,index)))
						 (setf ,myfs-par (append ,fs-par (list ,index)))
						 (loop (when (apply ,fn ,myfn-par)(return)) ,@body
						    (setf ,index (apply ,fs ,myfs-par))
						    (if (null ,index) (return))
						    (setf ,myfn-par (append ,fn-par (list ,index)))
						    (setf ,myfs-par (append ,fs-par (list ,index)))))
					  ;;当使用整数列表时,在'(for-next...列表中的整数列表参数,不能再使用',而需要直接写成(10 20)的形式!!!
					  (if ,fn
					      (progn (setf ,myfn-par (append ,fn-par (list ,index)))
						     (format t "fn-par=[~a]~%" ,fn-par )
						     (loop (when (apply ,fn ,myfn-par)(return)) ,@body (setf ,myfn-par (append ,fn-par (list ,index)))))
					      (format t "测试函数不存在.fn=[~a] fs=[~a]~%" ,fn ,fs)))))
								
		(t (format t "未定义的遍历类型[~a].~%" ,m-val)))))))
(defmacro 遍历(data method index &body body)
  `(travel ,data ,method ,index ,@body))

(defmacro 中断返回(loc &optional res)
  (if res
      `(return-from ,loc ,res)
      `(return-from ,loc)))
  
(defun range(i j &optional k)
  (let ((l nil))
    (if (null k) (setf k 1))
    (cond ((and (> i j)(< k 0))
	   (do ((ii i (+ ii k)))
	       ((<= ii j) (reverse l))
	     (push ii l)))
	  ((and (<= i j)(> k 0))
	   (do ((ii i (+ ii k)))
	       ((>= ii j) (reverse l))
	     (push ii l)))
	  (t (format t "[~a]到[~a]，步进为[~a]不是有效序列。~%" i j k)))))
  
(defun list-range(data i j &optional k)
  (let ((l nil))
    (if (null k) (setf k 1))
    (dolist (ii (range i j k))
      (push (nth ii data) l))
    (reverse l)))


